Libris Britannia 4/science library(b).zip/science library(b)/PROGRAMM/LOGO/H282.ZIP/MSWLOGO.ZIP/EXAMPLES.ZIP/PASCAL

Text File | 1992-11-01 | 22.0 KB | 895 lines

TO BUGFIX :VAL
OP INT :VAL
END
;;; All references to BUGFIX are because products aren't integers on the Mac

TO ACOUNT :ARRAY
OUTPUT COUNT :ARRAY
END

TO GARRAY :ARRAY :INDEX
OP ITEM BUGFIX :INDEX+1 :ARRAY
END

TO PARRAY :ARRAY :INDEX :VALUE
SETITEM BUGFIX :INDEX+1 :ARRAY :VALUE
END

TO ARGLIST
LOCAL [NAMES TYPE VARFLAG]
MAKE "VARFLAG "FALSE
IFBE "VAR [MAKE "VARFLAG "TRUE]
MAKE "NAMES COMMALIST [ID]
MUSTBE ":
MAKE "TYPE TOKEN
IF EQUALP :TYPE "PACKED [MAKE "TYPE TOKEN]
IFELSE EQUALP :TYPE "ARRAY [MAKE "TYPE ARRAYTYPE] [TYPECHECK :TYPE]
FOREACH :NAMES [NEWARG ? :TYPE NEWLNAME ? :VARFLAG]
IFBEELSE "|;| [ARGLIST] [MUSTBE "|)|]
END

TO ARRAYCOPY :TOTARGET :FROMTARGET
LOCAL [TO FROM]
MAKE "TO THING FIRST :TOTARGET
MAKE "FROM THING FIRST :FROMTARGET
FOR [I 0 [(ACOUNT :FROM) - 1]] [PARRAY :TO :I GARRAY :FROM :I]
END

TO ARRAYSIZE :TYPE
OUTPUT BUGFIX REDUCE "PRODUCT MAP [LAST ?] LAST :TYPE
END

TO ARRAYTYPE
LOCAL [RANGES TYPE]
MUSTBE "|[|
MAKE "RANGES COMMALIST [RANGE]
MUSTBE "|]|
MUSTBE "OF
MAKE "TYPE TOKEN
TYPECHECK :TYPE
OUTPUT LIST :TYPE :RANGES
END

TO BLOCK
LOCAL [BLOCKNAME CODEINTO]
MAKE "BLOCKNAME GENSYM
DEFINE :BLOCKNAME [[]]
MAKE "CODEINTO :BLOCKNAME
BLOCKBODY "END
OUTPUT (LIST :BLOCKNAME)
END

TO BLOCKBODY :ENDWORD
CODE STATEMENT
IFBEELSE "|;| [BLOCKBODY :ENDWORD] [MUSTBE :ENDWORD]
END

TO BOOLTOINT :EXPR
OUTPUT (SE [( IFELSE] :EXPR [[1] [0] )])
END

TO CHARTOINT :EXPR
OUTPUT (SE [( ASCII FIRST BF] :EXPR [)] )
END

TO CHARTOPRINT :CHARVAL
OUTPUT FIRST BF :CHARVAL
END

TO CODE :STUFF
IF EMPTYP :STUFF [STOP]
DEFINE :CODEINTO LPUT :STUFF TEXT :CODEINTO
END

TO COMMALIST :TEST [:SOFAR []]
LOCAL [RESULT TOKEN]
MAKE "RESULT RUN :TEST
IF EMPTYP :RESULT [OUTPUT :SOFAR]
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN ", [OUTPUT (COMMALIST :TEST (LPUT :RESULT :SOFAR))]
MAKE "PEEKTOKEN :TOKEN
OUTPUT LPUT :RESULT :SOFAR
END

TO COMPILE :FILE
LOCAL "ERROR
IF NAMEP "PEEKCHAR [ERN "PEEKCHAR]
IF NAMEP "PEEKTOKEN [ERN "PEEKTOKEN]
OPENREAD :FILE
SETREAD :FILE
IGNORE ERROR
CATCH "ERROR [PROGRAM]
MAKE "ERROR ERROR
IF NOT EMPTYP :ERROR ~
   [IF NOT EQUALP FIRST :ERROR 19 ~
       [PR FIRST BF :ERROR]]
SETREAD []
CLOSE :FILE
END

TO COPYOFARRAY :TARGET
LOCAL [TO FROM]
MAKE "FROM THING FIRST :TARGET
MAKE "TO ARRAY ACOUNT :FROM
FOR [I 0 [(ACOUNT :FROM) - 1]] [PARRAY :TO :I GARRAY :FROM :I]
END

TO FUNCTION
LOCAL [PROGNAME OLDIDLIST ARGLIST TYPE]
LOCAL "CODEINTO
MAKE "PROGNAME TOKEN
PUSH "IDLIST (LIST :PROGNAME "FUNCTION NEWLNAME :PROGNAME)
MAKE "OLDIDLIST :IDLIST
LOCAL "IDLIST
MAKE "IDLIST :OLDIDLIST
MAKE "ARGLIST []
MAKE LNAME :PROGNAME []
IFBE "|(| [ARGLIST]
MUSTBE ":
MAKE "TYPE TOKEN
TYPECHECK :TYPE
MAKE LNAME :PROGNAME FPUT :TYPE THING LNAME :PROGNAME
MUSTBE "|;|
DEFINE LNAME :PROGNAME (LIST :ARGLIST)
MAKE "CODEINTO LNAME :PROGNAME
CODE [LOCAL "RESULT]
PROGRAM1
CODE [OUTPUT :RESULT]
MUSTBE "|;|
END

TO GETCHAR
LOCAL "CHAR
IF NAMEP "PEEKCHAR [MAKE "CHAR :PEEKCHAR ERN "PEEKCHAR OUTPUT :CHAR]
IF EOFP [OUTPUT CHAR 1]
OUTPUT RC1
END

TO GETTYPE :WORD
LOCAL "RESULT
MAKE "RESULT LNAME1 :WORD :IDLIST
IF NOT EMPTYP :RESULT [OUTPUT ITEM 2 :RESULT]
PRINT SE [UNRECOGNIZED IDENTIFIER] :WORD
THROW "ERROR
END

TO ID
LOCAL "TOKEN
MAKE "TOKEN TOKEN
IF LETTERP ASCII FIRST :TOKEN [OUTPUT :TOKEN]
MAKE "PEEKTOKEN :TOKEN
OUTPUT []
END

TO IFBE :WANTED :ACTION
LOCAL "TOKEN
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN :WANTED [RUN :ACTION STOP]
MAKE "PEEKTOKEN :TOKEN
END

TO IFBEELSE :WANTED :ACTION :ELSE
LOCAL "TOKEN
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN :WANTED [RUN :ACTION STOP]
MAKE "PEEKTOKEN :TOKEN
RUN :ELSE
END

TO LETTERP :CODE
IF AND (:CODE > 64) (:CODE < 91) [OUTPUT "TRUE]
OUTPUT AND (:CODE > 96) (:CODE < 123)
END

TO LINDEX :BOUNDS :INDEX
OUTPUT LINDEX1 (OFFSET PINTEGER FIRST :INDEX FIRST FIRST :BOUNDS) ~
               BF :BOUNDS BF :INDEX
END

TO LINDEX1 :SOFAR :BOUNDS :INDEX
IF EMPTYP :BOUNDS [OUTPUT :SOFAR]
OUTPUT LINDEX1 (NEXTINDEX :SOFAR ~
                          LAST FIRST :BOUNDS ~
                          PINTEGER FIRST :INDEX ~
                          FIRST FIRST :BOUNDS) ~
               BF :BOUNDS BF :INDEX
END

TO LNAME :WORD
LOCAL "RESULT
MAKE "RESULT LNAME1 :WORD :IDLIST
IF NOT EMPTYP :RESULT [OUTPUT ITEM 3 :RESULT]
PRINT SE [UNRECOGNIZED IDENTIFIER] :WORD
THROW "ERROR
END

TO LNAME1 :WORD :LIST
IF EMPTYP :LIST [OUTPUT []]
IF EQUALP :WORD FIRST FIRST :LIST [OUTPUT FIRST :LIST]
OUTPUT LNAME1 :WORD BF :LIST
END

TO LPUSH :STACK :STUFF
MAKE :STACK LPUT :STUFF THING :STACK
END

TO MULT :A :B
OUTPUT (SE [( PRODUCT] :A :B [)] )
END

TO MUSTBE :WANTED
LOCAL "TOKEN
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN :WANTED [STOP]
PRINT (SE "EXPECTED :WANTED "GOT :TOKEN)
THROW "ERROR
END

TO NEWARG :PNAME :TYPE :LNAME :VARFLAG
IF RESERVEDP :PNAME [PR SE :PNAME [RESERVED WORD] THROW "ERROR]
PUSH "IDLIST IFELSE :VARFLAG ~
                    [(LIST :PNAME "VAR :LNAME :TYPE)] ~
                    [(LIST :PNAME :TYPE :LNAME)]
LPUSH "ARGLIST :LNAME
LPUSH LNAME :PROGNAME IFELSE :VARFLAG [LIST "VAR :TYPE] [:TYPE]
END

TO NEWLNAME :WORD
IF MEMBERP :WORD :NAMESUSED [OUTPUT GENSYM]
IF NAMEP WORD "% :WORD [OUTPUT GENSYM]
PUSH "NAMESUSED :WORD
OUTPUT WORD "% :WORD
END

TO NEWVAR :PNAME :TYPE :LNAME
IF RESERVEDP :PNAME [PR SE :PNAME [RESERVED WORD] THROW "ERROR]
PUSH "IDLIST (LIST :PNAME :TYPE :LNAME)
CODE LIST "LOCAL WORD "" :LNAME
IF LISTP :TYPE [CODE (LIST "MAKE WORD "" :LNAME "ARRAY ARRAYSIZE :TYPE)]
END

TO NEXTINDEX :OLD :FACTOR :NEW :OFFSET
OUTPUT (SE [( SUM] (MULT :OLD :FACTOR) (OFFSET :NEW :OFFSET) [)] )
END

TO NUMBER :NUM
LOCAL "CHAR
MAKE "CHAR GETCHAR
IF EQUALP :CHAR ". ~
   [MAKE "CHAR GETCHAR ~
    IFELSE EQUALP :CHAR ". ~
           [MAKE "PEEKTOKEN ".. OUTPUT :NUM] ~
           [MAKE "PEEKCHAR :CHAR OUTPUT NUMBER WORD :NUM ".]]
IF EQUALP :CHAR "E [OUTPUT NUMBER WORD :NUM TWOCHAR "E [+ -]]
IF NUMBERP :CHAR [OUTPUT NUMBER WORD :NUM :CHAR]
MAKE "PEEKCHAR :CHAR
OUTPUT :NUM
END

TO NUMTYPE :NUMBER
IF MEMBERP ". :NUMBER [OUTPUT "REAL]
IF MEMBERP "E :NUMBER [OUTPUT "REAL]
OUTPUT "INTEGER
END

TO OFFSET :A :B
OUTPUT (SE [( DIFFERENCE] :A :B [)] )
END

TO OPSETUP
PPROP "|=| "BINARY [EQUALP 2 [BOOLEAN []] 1]
PPROP "|<>| "BINARY [[NOT EQUALP] 2 [BOOLEAN []] 1]
PPROP "|<| "BINARY [LESSP 2 [BOOLEAN []] 1]
PPROP "|>| "BINARY [GREATERP 2 [BOOLEAN []] 1]
PPROP "|<=| "BINARY [[NOT GREATERP] 2 [BOOLEAN []] 1]
PPROP "|>=| "BINARY [[NOT LESSP] 2 [BOOLEAN []] 1]
PPROP "|+| "BINARY [SUM 2 2]
PPROP "|-| "BINARY [DIFFERENCE 2 2]
PPROP "OR "BINARY [OR 2 [BOOLEAN BOOLEAN] 2]
PPROP "|*| "BINARY [PRODUCT 2 3]
PPROP "|/| "BINARY [QUOTIENT 2 [REAL []] 3]
PPROP "DIV "BINARY [[INT QUOTIENT] 2 [INTEGER INTEGER] 3]
PPROP "MOD "BINARY [REMAINDER 2 [INTEGER INTEGER] 3]
PPROP "AND "BINARY [AND 2 [BOOLEAN BOOLEAN] 3]
PPROP "|+| "UNARY [[] 1 4]
PPROP "|-| "UNARY [MINUS 1 4]
PPROP "NOT "UNARY [NOT 1 [BOOLEAN BOOLEAN] 4]
MAKE "IDLIST [[TRUNC FUNCTION INT] ~
              [ROUND FUNCTION ROUND] [RANDOM FUNCTION RANDOM]]
MAKE "INT [INTEGER REAL]
MAKE "ROUND [INTEGER REAL]
MAKE "RANDOM [INTEGER INTEGER]
END

TO PARRAYASSIGN :NAME :TYPE :TARGET
LOCAL [RIGHT RTYPE RLNAME RTARGET]
MAKE "RIGHT TOKEN
IF EQUALP FIRST :RIGHT "' [OUTPUT PSTRINGASSIGN :TARGET :TYPE (BL BF :RIGHT)]
MAKE "RTYPE GETTYPE :RIGHT
MAKE "RLNAME LNAME :RIGHT
IFELSE EQUALP :RTYPE "VAR [PVARRIGHT] [MAKE "RTARGET (LIST :RLNAME)]
IF EQUALP :TYPE :RTYPE [OUTPUT (LIST "ARRAYCOPY :TARGET :RTARGET)]
PR (SE "ARRAYS :NAME "AND :RIGHT [UNEQUAL TYPES])
THROW "ERROR
END

TO PARRAYDATA :PNAME :TYPE :TARGET
LOCAL "INDEX
MUSTBE "|[|
MAKE "INDEX COMMALIST [PEXPR]
MUSTBE "|]|
MAKE "INDEX LINDEX LAST :TYPE :INDEX
MAKE "TYPE FIRST :TYPE
MAKE "TARGET SE :TARGET :INDEX
OUTPUT PMAYBECHAR :TYPE (LIST "PTHING :TARGET)
END

TO PASSIGN
LOCAL [NAME TYPE INDEX VALUE LNAME TARGET]
MAKE "NAME TOKEN
MAKE "INDEX []
IFBE "|[| [MAKE "INDEX COMMALIST [PEXPR] MUSTBE "|]|]
MUSTBE "|:=|
MAKE "LNAME LNAME :NAME
MAKE "TYPE GETTYPE :NAME
OUTPUT PASSIGN1
END

TO PASSIGN1
IFELSE EQUALP :TYPE "VAR [PVARASSIGN :NAME] [MAKE "TARGET (LIST :LNAME)]
IF AND (LISTP :TYPE) (EMPTYP :INDEX) [OUTPUT PARRAYASSIGN :NAME :TYPE :TARGET]
IF LISTP :TYPE [MAKE "INDEX LINDEX LAST :TYPE :INDEX MAKE "TYPE FIRST :TYPE]
IF NOT EMPTYP :INDEX [MAKE "TARGET SE :TARGET :INDEX]
MAKE "VALUE PEXPR
IF EQUALP :TYPE "REAL [MAKE "VALUE PREAL :VALUE]
IF EQUALP :TYPE "INTEGER [MAKE "VALUE PINTEGER :VALUE]
IF EQUALP :TYPE "CHAR [MAKE "VALUE PCHAR :VALUE]
IF EQUALP :TYPE "BOOLEAN [MAKE "VALUE PBOOLEAN :VALUE]
OUTPUT (SE (LIST "PMAKE :TARGET) :VALUE)
END

TO PBOOLEAN :EXPR
IF EQUALP FIRST :EXPR "BOOLEAN [OUTPUT LAST :EXPR]
PR SE LAST :COND [NOT TRUE OR FALSE]
THROW "ERROR
END

TO PCHAR :EXPR
IF EQUALP FIRST :EXPR "CHAR [OUTPUT LAST :EXPR]
PR SE LAST :COND [NOT CHARACTER VALUE]
THROW "ERROR
END

TO PCHARDATA :TOKEN
IF NOT EQUALP COUNT :TOKEN 3 [PR SE :TOKEN [NOT SINGLE CHARACTER] THROW "ERROR]
OUTPUT LIST "CHAR WORD "" :TOKEN
END

TO PCHECKTYPE :WANT :LEFT :RIGHT
IF NOT EQUALP :WANT :LEFT [PR (SE :LEFT "ISN'T :WANT) THROW "ERROR]
IF NOT EQUALP :WANT :RIGHT [PR (SE :RIGHT "ISN'T :WANT) THROW "ERROR]
END

TO PCLOSE
WHILE [(LAST FIRST :OPSTACK) > 0] [PPOPOP]
IGNORE POP "OPSTACK
MAKE "PARENLEVEL :PARENLEVEL - 1
END

TO PDATA :TOKEN
LOCAL [TYPE LNAME TARGET]
IF EQUALP :TOKEN "TRUE [OUTPUT [BOOLEAN "TRUE]]
IF EQUALP :TOKEN "FALSE [OUTPUT [BOOLEAN "FALSE]]
IF EQUALP FIRST :TOKEN "' [OUTPUT PCHARDATA :TOKEN]
IF NUMBERP :TOKEN [OUTPUT LIST NUMTYPE :TOKEN :TOKEN]
MAKE "TYPE GETTYPE :TOKEN
IF EMPTYP :TYPE [PR SE [UNDEFINED SYMBOL] :TOKEN THROW "ERROR]
MAKE "LNAME LNAME :TOKEN
IFELSE EQUALP :TYPE "VAR [PVARASSIGN :TOKEN] [MAKE "TARGET (LIST :LNAME)]
IF EQUALP :TYPE "FUNCTION [OUTPUT PFUNCALL :TOKEN]
IF LISTP :TYPE [OUTPUT PARRAYDATA :TOKEN :TYPE :TARGET]
OUTPUT PMAYBECHAR :TYPE LIST "PTHING :TARGET
END

TO PEXPR
LOCAL [OPSTACK DATASTACK PARENLEVEL]
MAKE "OPSTACK [[POPEN 1 0]]
MAKE "DATASTACK []
MAKE "PARENLEVEL 0
OUTPUT PEXPR1
END

TO PEXPR1
LOCAL [TOKEN OP]
MAKE "TOKEN TOKEN
WHILE [EQUALP :TOKEN "|(|] [POPEN MAKE "TOKEN TOKEN]
MAKE "OP PGETUNARY :TOKEN
IF NOT EMPTYP :OP [OUTPUT PEXPROP :OP]
PUSH "DATASTACK PDATA :TOKEN
MAKE "TOKEN TOKEN
WHILE [AND (:PARENLEVEL > 0) (EQUALP :TOKEN "|)| )] [PCLOSE MAKE "TOKEN TOKEN]
MAKE "OP PGETBINARY :TOKEN
IF NOT EMPTYP :OP [OUTPUT PEXPROP :OP]
MAKE "PEEKTOKEN :TOKEN
PCLOSE
IF NOT EMPTYP :OPSTACK [PR [TOO MANY OPERATORS] THROW "ERROR]
IF NOT EMPTYP BF :DATASTACK [PR [TOO MANY OPERANDS] THROW "ERROR]
OUTPUT POP "DATASTACK
END

TO PEXPROP :OP
WHILE [(LAST :OP) < (1 + LAST FIRST :OPSTACK)] [PPOPOP]
PUSH "OPSTACK :OP
OUTPUT PEXPR1
END

TO PFOR
LOCAL [VAR INIT STEP FINAL ACTION]
MAKE "VAR TOKEN
MUSTBE "|:=|
MAKE "INIT PINTEGER PEXPR
MAKE "STEP 1
IFBEELSE "DOWNTO [MAKE "STEP -1] [MUSTBE "TO]
MAKE "FINAL PINTEGER PEXPR
MUSTBE "DO
MAKE "ACTION STATEMENT
OUTPUT (LIST "FOR (LIST LNAME :VAR :INIT :FINAL :STEP) :ACTION)
END

TO PFUNCALL :PNAME
LOCAL [LNAME VARTYPES]
MAKE "LNAME LNAME :PNAME
MAKE "VARTYPES THING :LNAME
IF EMPTYP BF :VARTYPES [OUTPUT LIST FIRST :VARTYPES :LNAME]
MUSTBE "|(|
OUTPUT LIST FIRST :VARTYPES FPUT :LNAME PROCARGS BF :VARTYPES
END

TO PFUNSET
LOCAL [NAME TYPE INDEX VALUE LNAME TARGET]
MAKE "NAME TOKEN
MAKE "INDEX []
IF NOT EQUALP :NAME :PROGNAME [PR SE [ASSIGN TO WRONG FUNCTION] :NAME THROW "ERROR]
MUSTBE "|:=|
MAKE "LNAME "RESULT
MAKE "TYPE FIRST THING LNAME :NAME
OUTPUT PASSIGN1
END

TO PGETBINARY :TOKEN
OUTPUT GPROP :TOKEN "BINARY
END

TO PGETUNARY :TOKEN
OUTPUT GPROP :TOKEN "UNARY
END

TO PIF
LOCAL [COND THEN ELSE]
MAKE "COND PBOOLEAN PEXPR
MUSTBE "THEN
MAKE "THEN STATEMENT
MAKE "ELSE []
IFBE "ELSE [MAKE "ELSE STATEMENT]
OUTPUT (SE "IFELSE :COND (LIST :THEN) (LIST :ELSE))
END

TO PINTEGER :PVAL
LOCAL "TYPE
MAKE "TYPE FIRST :PVAL
IF EQUALP :TYPE "INTEGER [OUTPUT LAST :PVAL]
IF EQUALP :TYPE "BOOLEAN [OUTPUT BOOLTOINT LAST :PVAL]
IF EQUALP :TYPE "CHAR [OUTPUT CHARTOINT LAST :PVAL]
PR SE LAST :PVAL [ISN'T ORDINAL]
THROW "ERROR
END

TO PMAKE :TARGET :VALUE
IFELSE EMPTYP BF :TARGET ~
       [MAKE FIRST :TARGET :VALUE] ~
       [PARRAY TARGETVAR FIRST :TARGET RUN BF :TARGET :VALUE]
END

TO PMAYBECHAR :TYPE :VAL
IF EQUALP :TYPE "CHAR [OUTPUT LIST "CHAR SE "PVARTOCHAR :VAL]
OUTPUT LIST :TYPE :VAL
END

TO PNEWTYPE :OP :LTYPE :RTYPE
LOCAL "TYPE
MAKE "TYPE (IFELSE (COUNT :OP) > 3 [ITEM 3 :OP] [[[] []]])
IF EMPTYP :LTYPE [MAKE "LTYPE :RTYPE]
IF NOT EMPTYP LAST :TYPE [PCHECKTYPE LAST :TYPE :LTYPE :RTYPE]
IF AND (EQUALP :LTYPE "REAL) (EQUALP :RTYPE "INTEGER) [MAKE "RTYPE "REAL]
IF AND (EQUALP :LTYPE "INTEGER) (EQUALP :RTYPE "REAL) [MAKE "LTYPE "REAL]
IF NOT EQUALP :LTYPE :RTYPE [PR [TYPE CLASH] THROW "ERROR]
IF EMPTYP LAST :TYPE ~
   [IF NOT MEMBERP :RTYPE [INTEGER REAL] [PR [NONARITHMETIC TYPE] THROW "ERROR]]
IF EMPTYP FIRST :TYPE [OUTPUT :RTYPE]
OUTPUT FIRST :TYPE
END

TO POPEN
PUSH "OPSTACK [POPEN 1 0]
MAKE "PARENLEVEL :PARENLEVEL + 1
END

TO PPOPOP
LOCAL [OP FUNCTION ARGS LEFT RIGHT TYPE]
MAKE "OP POP "OPSTACK
MAKE "FUNCTION FIRST :OP
MAKE "ARGS FIRST BF :OP
MAKE "RIGHT POP "DATASTACK
MAKE "LEFT (IFELSE EQUALP :ARGS 2 [POP "DATASTACK] [[[] []]])
MAKE "TYPE PNEWTYPE :OP FIRST :LEFT FIRST :RIGHT
PUSH "DATASTACK LIST :TYPE (SE [(] :FUNCTION LAST :LEFT LAST :RIGHT [)] )
END

TO PPROCCALL
LOCAL [PNAME LNAME VARTYPES]
MAKE "PNAME TOKEN
MAKE "LNAME LNAME :PNAME
MAKE "VARTYPES THING :LNAME
IF EMPTYP :VARTYPES [OUTPUT (LIST :LNAME)]
MUSTBE "|(|
OUTPUT FPUT :LNAME PROCARGS :VARTYPES
END

TO PREAL :PVAL
IF EQUALP FIRST :PVAL "REAL [OUTPUT LAST :PVAL]
OUTPUT PINTEGER :PVAL
END

TO PREPEAT
LOCAL [COND BLOCKNAME CODEINTO]
MAKE "BLOCKNAME GENSYM
DEFINE :BLOCKNAME [[]]
MAKE "CODEINTO :BLOCKNAME
BLOCKBODY "UNTIL
MAKE "COND PBOOLEAN PEXPR
OUTPUT (LIST "DOUNTIL (LIST :BLOCKNAME) :COND)
END

TO PRINTSIZE :SIZE :STUFF
IF NOT (:SIZE > COUNT :STUFF) [OUTPUT :STUFF]
OUTPUT PRINTSIZE :SIZE WORD "| | :STUFF
END

TO PROCARG :TYPE
LOCAL "RESULT
IF EQUALP FIRST :TYPE "VAR [OUTPUT PROCVARARG LAST :TYPE]
IF LISTP :TYPE [OUTPUT PROCARRAYARG :TYPE]
MAKE "RESULT PEXPR
IF EQUALP :TYPE "REAL [MAKE "RESULT PREAL :RESULT]
IF EQUALP :TYPE "INTEGER [MAKE "RESULT PINTEGER :RESULT]
IF EQUALP :TYPE "CHAR [MAKE "RESULT PCHAR :RESULT]
IF EQUALP :TYPE "BOOLEAN [MAKE "RESULT PBOOLEAN :RESULT]
OUTPUT :RESULT
END

TO PROCARGS :TYPES
LOCAL "NEXT
IF EMPTYP :TYPES [MUSTBE "|)| OUTPUT []]
MAKE "NEXT PROCARG FIRST :TYPES
IF NOT EMPTYP BF :TYPES [MUSTBE ",]
OUTPUT SE :NEXT PROCARGS BF :TYPES
END

TO PROCARRAYARG :TYPE
LOCAL [PNAME TYPE LNAME TARGET]
MAKE "PNAME TOKEN
MAKE "TYPE GETTYPE :PNAME
MAKE "LNAME LNAME :PNAME
IFELSE EQUALP :TYPE "VAR [PVARASSIGN] [MAKE "TARGET (LIST :LNAME)]
OUTPUT LIST "COPYOFARRAY :TARGET
END

TO PROCEDURE
LOCAL [PROGNAME OLDIDLIST CODEINTO ARGLIST]
MAKE "PROGNAME TOKEN
PUSH "IDLIST (LIST :PROGNAME "PROCEDURE NEWLNAME :PROGNAME)
MAKE "OLDIDLIST :IDLIST
LOCAL "IDLIST
MAKE "IDLIST :OLDIDLIST
MAKE "CODEINTO LNAME :PROGNAME
MAKE "ARGLIST []
MAKE LNAME :PROGNAME []
IFBE "|(| [ARGLIST]
MUSTBE "|;|
DEFINE LNAME :PROGNAME (LIST :ARGLIST)
PROGRAM1
MUSTBE "|;|
END

TO PROCVARARG :FTYPE
LOCAL [PNAME TYPE LNAME TARGET]
MAKE "PNAME TOKEN
MAKE "TYPE GETTYPE :PNAME
MAKE "LNAME LNAME :PNAME
IFELSE EQUALP :TYPE "VAR [PVARASSIGN :PNAME] [MAKE "TARGET (LIST :LNAME)]
IF AND (LISTP :TYPE) (WORDP :FTYPE) [OUTPUT PROCVARARGARRAY :FTYPE :TYPE :TARGET]
IF NOT EQUALP :TYPE :FTYPE [PR SE :PNAME [ARG WRONG TYPE] THROW "ERROR]
OUTPUT (LIST :TARGET)
END

TO PROCVARARGARRAY :FTYPE :TYPE :TARGET
IF NOT EQUALP :FTYPE FIRST :TYPE [PR SE :PNAME [ARG WRONG TYPE] THROW "ERROR]
LOCAL "INDEX
MUSTBE "|[|
MAKE "INDEX COMMALIST [PEXPR]
MUSTBE "|]|
MAKE "INDEX LINDEX LAST :TYPE :INDEX
OUTPUT (LIST SE :TARGET :INDEX)
END

TO PROGRAM
LOCAL [PROGNAME OLDIDLIST NAMESUSED CODEINTO]
MAKE "NAMESUSED []
MUSTBE "PROGRAM
MAKE "PROGNAME TOKEN
MUSTBE "|(|
IGNORE COMMALIST [ID]
MUSTBE "|)|
MUSTBE "|;|
IF NOT NAMEP "IDLIST [OPSETUP]
MAKE "OLDIDLIST :IDLIST
LOCAL "IDLIST
MAKE "IDLIST :OLDIDLIST
PUSH "IDLIST (LIST :PROGNAME "PROGRAM NEWLNAME :PROGNAME)
DEFINE LNAME :PROGNAME [[]]
MAKE "CODEINTO LNAME :PROGNAME
PROGRAM1
MUSTBE ".
END

TO PROGRAM1
IFBE "VAR [VARPART]
TRYPROCPART
MUSTBE "BEGIN
BLOCKBODY "END
END

TO PRUN :PROGNAME
RUN FPUT WORD "% :PROGNAME []
END

TO PSTRINGASSIGN :TARGET :TYPE :STRING
IF NOT EQUALP FIRST :TYPE "CHAR [STRINGLOSE]
IF NOT EMPTYP BF LAST :TYPE [STRINGLOSE]
IF NOT EQUALP (LAST FIRST LAST :TYPE) (COUNT :STRING) [STRINGLOSE]
OUTPUT (LIST "STRINGCOPY :TARGET WORD "" :STRING)
END

TO PTHING :TARGET
IF EMPTYP BF :TARGET [OUTPUT THING FIRST :TARGET]
OUTPUT GARRAY TARGETVAR FIRST :TARGET RUN BF :TARGET
END

TO PUSH :STACK :ITEM
MAKE :STACK FPUT :ITEM THING :STACK
END

TO PVARASSIGN :NAME
LOCAL "ID
MAKE "ID LNAME1 :NAME :IDLIST
MAKE "TYPE LAST :ID
MAKE "TARGET WORD ": :LNAME
END

TO PVARRIGHT
LOCAL "ID
MAKE "ID LNAME1 :RIGHT :IDLIST
MAKE "RTYPE LAST :ID
MAKE "RTARGET WORD ": :RLNAME
END

TO PVARTOCHAR :VALUE
IF NUMBERP :VALUE [OUTPUT CHAR :VALUE]
OUTPUT :VALUE
END

TO PWHILE
LOCAL [COND ACTION]
MAKE "COND PBOOLEAN PEXPR
MUSTBE "DO
MAKE "ACTION STATEMENT
OUTPUT (LIST "WHILE :COND :ACTION)
END

TO PWRITE
MUSTBE "|(|
OUTPUT (SE [( TYPE] PWRITE1 [)] )
END

TO PWRITE1
LOCAL [RESULT TOKEN]
MAKE "RESULT PWRITE2
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN "|)| [OUTPUT :RESULT]
IF NOT EQUALP :TOKEN ", [PR SE [EXPECTED , GOT] :TOKEN THROW "ERROR]
OUTPUT SE :RESULT PWRITE1
END

TO PWRITE2
LOCAL "RESULT
MAKE "RESULT PWRITE3
IFBE ": [MAKE "RESULT (SE "PRINTSIZE TOKEN BF BF :RESULT)]
OUTPUT :RESULT
END

TO PWRITE3
LOCAL [TOKEN RESULT]
MAKE "TOKEN TOKEN
IF EQUALP FIRST :TOKEN "' [OUTPUT (LIST "PRINTSIZE 1 "FIRST (LIST BL BF :TOKEN))]
MAKE "PEEKTOKEN :TOKEN
MAKE "RESULT PEXPR
IF EQUALP FIRST :RESULT "CHAR [OUTPUT SE [PRINTSIZE 1 CHARTOPRINT] LAST :RESULT]
IF EQUALP FIRST :RESULT "BOOLEAN [OUTPUT SE [PRINTSIZE 1] LAST :RESULT]
IF EQUALP FIRST :RESULT "INTEGER [OUTPUT SE [PRINTSIZE 10] LAST :RESULT]
OUTPUT SE [PRINTSIZE 20] LAST :RESULT
END

TO PWRITELN
LOCAL "TOKEN
MAKE "TOKEN TOKEN
MAKE "PEEKTOKEN :TOKEN
IF NOT EQUALP :TOKEN "|(| [OUTPUT [PRINT []]]
OUTPUT SE PWRITE [PRINT []]
END

TO RANGE
LOCAL [FIRST LAST]
MAKE "FIRST RANGE1
MUSTBE "..
MAKE "LAST RANGE1
IF :FIRST > :LAST ~
   [PR (SE [ARRAY BOUNDS NOT INCREASING:] :FIRST ".. :LAST) THROW "ERROR]
OUTPUT LIST :FIRST (1 + :LAST - :FIRST)
END

TO RANGE1
LOCAL "BOUND
MAKE "BOUND TOKEN
IF EQUALP FIRST :BOUND "' [OUTPUT ASCII FIRST BF :BOUND]
IF EQUALP :BOUND "|-| [MAKE "BOUND MINUS TOKEN]
IF EQUALP :BOUND INT :BOUND [OUTPUT :BOUND]
PR SE [ARRAY BOUND NOT ORDINAL:] :BOUND
THROW "ERROR
END

TO RC1
LOCAL "RESULT
MAKE "RESULT RC
TYPE :RESULT
OUTPUT :RESULT
END

TO RESERVEDP :WORD
OUTPUT MEMBERP :WORD [AND ARRAY BEGIN CASE CONST DIV DO DOWNTO ELSE END ~
                      FILE FOR FORWARD FUNCTION GOTO IF IN LABEL MOD NIL ~
                      NOT OF PACKED PROCEDURE PROGRAM RECORD REPEAT SET ~
                      THEN TO TYPE UNTIL VAR WHILE WITH]
END

TO SKIPCOMMENT
IF EQUALP GETCHAR "|}| [STOP]
SKIPCOMMENT
END

TO STATEMENT
LOCAL [TOKEN TYPE]
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN "BEGIN [OUTPUT BLOCK]
IF EQUALP :TOKEN "FOR [OUTPUT PFOR]
IF EQUALP :TOKEN "IF [OUTPUT PIF]
IF EQUALP :TOKEN "WHILE [OUTPUT PWHILE]
IF EQUALP :TOKEN "REPEAT [OUTPUT PREPEAT]
IF EQUALP :TOKEN "WRITE [OUTPUT PWRITE]
IF EQUALP :TOKEN "WRITELN [OUTPUT PWRITELN]
MAKE "PEEKTOKEN :TOKEN
IF MEMBERP :TOKEN [|;| END UNTIL] [OUTPUT []]
MAKE "TYPE GETTYPE :TOKEN
IF EMPTYP :TYPE [PR SE :TOKEN [CAN'T BEGIN STATEMENT] THROW "ERROR]
IF EQUALP :TYPE "PROCEDURE [OUTPUT PPROCCALL]
IF EQUALP :TYPE "FUNCTION [OUTPUT PFUNSET]
OUTPUT PASSIGN
END

TO STRING :STRING
LOCAL "CHAR
MAKE "CHAR GETCHAR
IF NOT EQUALP :CHAR "' [OUTPUT STRING WORD :STRING :CHAR]
MAKE "CHAR GETCHAR
IF EQUALP :CHAR "' [OUTPUT STRING WORD :STRING :CHAR]
MAKE "PEEKCHAR :CHAR
OUTPUT WORD :STRING "'
END

TO STRINGCOPY :TOTARGET :FROM
LOCAL [I TO]
MAKE "TO THING FIRST :TOTARGET
MAKE "I 0
FOREACH :FROM [PARRAY :TO :I (WORD "' ? "') MAKE "I :I + 1]
END

TO STRINGLOSE
PR SE :NAME [NOT STRING ARRAY OR WRONG SIZE]
THROW "ERROR
END

TO TARGETVAR :WORD
IF EQUALP FIRST :WORD ": [OUTPUT THING THING BF :WORD]
OUTPUT THING :WORD
END

TO TOKEN
LOCAL [TOKEN CHAR]
IF NAMEP "PEEKTOKEN [MAKE "TOKEN :PEEKTOKEN ERN "PEEKTOKEN OUTPUT :TOKEN]
MAKE "CHAR GETCHAR
IF EQUALP :CHAR "|{| [SKIPCOMMENT OUTPUT TOKEN]
IF EQUALP :CHAR CHAR 32 [OUTPUT TOKEN]
IF EQUALP :CHAR CHAR 13 [OUTPUT TOKEN]
IF EQUALP :CHAR CHAR 10 [OUTPUT TOKEN]
IF EQUALP :CHAR "' [OUTPUT STRING "']
IF MEMBERP :CHAR [+ - * / = ( , ) |[| |]| |;|] [OUTPUT :CHAR]
IF EQUALP :CHAR "|<| [OUTPUT TWOCHAR "|<| [= >]]
IF EQUALP :CHAR "|>| [OUTPUT TWOCHAR "|>| [=]]
IF EQUALP :CHAR ". [OUTPUT TWOCHAR ". [.]]
IF EQUALP :CHAR ": [OUTPUT TWOCHAR ": [=]]
IF NUMBERP :CHAR [OUTPUT NUMBER :CHAR]
IF LETTERP ASCII :CHAR [OUTPUT TOKEN1 UC :CHAR]
PR SE [UNRECOGNIZED CHARACTER:] :CHAR
THROW "ERROR
END

TO TOKEN1 :TOKEN
LOCAL "CHAR
MAKE "CHAR GETCHAR
IF OR LETTERP ASCII :CHAR NUMBERP :CHAR [OUTPUT TOKEN1 WORD :TOKEN UC :CHAR]
MAKE "PEEKCHAR :CHAR
OUTPUT :TOKEN
END

TO TRYPROCPART
IFBEELSE "PROCEDURE ~
         [PROCEDURE TRYPROCPART] ~
         [IFBE "FUNCTION [FUNCTION TRYPROCPART]]
END

TO TWOCHAR :OLD :OK
LOCAL "CHAR
MAKE "CHAR GETCHAR
IF MEMBERP :CHAR :OK [OUTPUT WORD :OLD :CHAR]
MAKE "PEEKCHAR :CHAR
OUTPUT :OLD
END

TO TYPECHECK :TYPE
IF MEMBERP :TYPE [REAL INTEGER CHAR BOOLEAN] [STOP]
PRINT SE [UNDEFINED TYPE] :TYPE
THROW "ERROR
END

TO UC :CHAR
LOCAL "CODE
MAKE "CODE ASCII :CHAR
IF OR (:CODE < 97) (:CODE > 122) [OUTPUT :CHAR]
OUTPUT CHAR :CODE - 32
END

TO VARPART
LOCAL [TOKEN NAMELIST]
MAKE "TOKEN TOKEN
MAKE "PEEKTOKEN :TOKEN
IF RESERVEDP :TOKEN [STOP]
MAKE "NAMELIST COMMALIST [ID]
MUSTBE ":
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN "PACKED [MAKE "TOKEN TOKEN]
IFELSE EQUALP :TOKEN "ARRAY [MAKE "TOKEN ARRAYTYPE] [TYPECHECK :TOKEN]
MUSTBE "|;|
FOREACH :NAMELIST [NEWVAR ? :TOKEN NEWLNAME ?]
VARPART
END